home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / gcl-patches.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  6KB  |  169 lines
  1. ;;; -*- Mode:Lisp; Package:USER; Base:10; Syntax:Common-lisp -*-
  2.  
  3. (in-package 'user)
  4.  
  5. (setq c::optimize-speed 3)
  6. (setq c::optimize-safety 0)
  7. (setq c::optimize-space 0)
  8.  
  9. (remprop 'macroexpand 'c::fdesc)
  10. (remprop 'macroexpand-1 'c::fdesc)
  11.  
  12.  
  13. ;;; this is here to fix the printer so it will find the print
  14. ;;; functions on structures that have 'em.
  15.  
  16. (in-package 'lisp)
  17.  
  18. (defun %write-structure (struct output-stream print-vars level)
  19.   (let* ((name (svref struct 0))
  20.      (pfun (or (let ((temp (get name 'structure-descriptor)))
  21.               (and temp (dd-print-function temp)))
  22.             (get name :print-function))))
  23.     (declare (symbol name))
  24.     (cond
  25.       (pfun
  26.     (funcall pfun struct output-stream level))
  27.       ((and (pv-level print-vars) (>= level (pv-level print-vars)))
  28.        (write-char #\# output-stream))
  29.       ((and (pv-circle print-vars)
  30.             (%write-circle struct output-stream (pv-circle print-vars))))
  31.       (t
  32.        (let ((pv-length (pv-length print-vars))
  33.          (pv-pretty (pv-pretty print-vars)))
  34.      (when pv-pretty
  35.        (pp-push-level pv-pretty))
  36.      (incf level)
  37.      (write-string "#s(" output-stream)
  38.      (cond
  39.       ((and pv-length (>= 0 pv-length))
  40.        (write-string "..."))
  41.       (t
  42.        (%write-symbol name output-stream print-vars)
  43.        (do ((i 0 (1+ i))
  44.         (n 0)
  45.         (slots (dd-slots (get name 'structure-descriptor))
  46.                (rest slots)))
  47.            ((endp slots))
  48.          (declare (fixnum i n) (list slots))
  49.          (when pv-pretty
  50.            (pp-insert-break pv-pretty *structure-keyword-slot-spec* t))
  51.          (write-char #\space output-stream)
  52.          (when (and pv-length (>= (incf n) pv-length))
  53.            (write-string "..." output-stream)
  54.            (return))
  55.          (write-char #\: output-stream)
  56.          (%write-symbol-name
  57.           (symbol-name (dsd-name (first slots))) output-stream print-vars)
  58.          (when pv-pretty
  59.            (pp-insert-break pv-pretty *structure-data-slot-spec* nil))
  60.          (write-char #\space output-stream)
  61.          (when (and pv-length (>= (incf n) pv-length))
  62.            (write-string "..." output-stream)
  63.            (return))
  64.          (%write-object
  65.           (svref struct (dsd-index (first slots)))
  66.           output-stream print-vars level))))
  67.      (write-char #\) output-stream)
  68.      (when pv-pretty
  69.        (pp-pop-level pv-pretty)))))))
  70.  
  71. (eval-when (eval) (compile '%write-structure))
  72.  
  73. ;;;
  74. ;;; Apparently, whoever implemented the TIME macro didn't consider that
  75. ;;; someone might want to use it in a non-null lexical environment.  Of
  76. ;;; course this fix is a loser since it binds a whole mess of variables
  77. ;;; around the evaluation of form, but it will do for now.
  78. ;;;
  79. (in-package 'lisp)
  80.  
  81. (DEFmacro TIME (FORM)
  82.   `(LET (IGNORE START FINISH S-HSEC F-HSEC S-SEC F-SEC S-MIN F-MIN VALS)
  83.      (FORMAT *trace-output* "~&Evaluating: ~A" ,form)
  84.      ;; read the start time.
  85.      (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE S-MIN START)
  86.        (SYS::%SYSINT #X21 #X2C00 0 0 0))
  87.      ;; Eval the form.
  88.      (SETQ VALS (MULTIPLE-VALUE-LIST (progn ,form)))
  89.      ;; Read the end time.
  90.      (MULTIPLE-VALUE-SETQ (IGNORE IGNORE IGNORE F-MIN FINISH)
  91.        (SYS::%SYSINT #X21 #X2C00 0 0 0))
  92.      ;; Unpack start and end times.
  93.      (SETQ S-HSEC (LOGAND START #X0FF)
  94.        F-HSEC (LOGAND FINISH #X0FF)
  95.        S-SEC (LSH START -8)
  96.            F-SEC (LSH FINISH -8)
  97.        S-MIN (LOGAND #X0FF S-MIN)
  98.        F-MIN (LOGAND #X0FF F-MIN))
  99.      (SETQ F-HSEC (- F-HSEC S-HSEC))            ; calc hundreths
  100.      (IF (MINUSP F-HSEC)
  101.          (SETQ F-HSEC (+ F-HSEC 100)
  102.            F-SEC (1- F-SEC)))
  103.      (SETQ F-SEC (- F-SEC S-SEC))            ; calc seconds
  104.      (IF (MINUSP F-SEC)
  105.          (SETQ F-SEC (+ F-SEC 60)
  106.            F-MIN (1- F-MIN)))
  107.      (SETQ F-MIN (- F-MIN S-MIN))            ; calc minutes
  108.      (IF (MINUSP F-MIN) (INCF F-MIN 60))
  109.      (FORMAT *trace-output* "~&Elapsed time: ~D:~:[~D~;0~D~].~:[~D~;0~D~]~%"
  110.        F-MIN (< F-SEC 10.) F-SEC (< F-HSEC 10) F-HSEC)
  111.      (VALUES-LIST VALS)))
  112.  
  113. ;;;
  114. ;;; Patch to PROGV
  115. ;;; 
  116. (in-package sys::*compiler-package-load*)
  117.  
  118. ;;; This is a fully portable (though not very efficient)
  119. ;;; implementation of PROGV as a macro.  It does its own special
  120. ;;; binding (shallow binding) by saving the original values in a
  121. ;;; list, and marking things that were originally unbound.
  122.  
  123. (defun PORTABLE-PROGV-BIND (symbol old-vals place-holder)
  124.   (let ((val-to-save '#:value-to-save))
  125.     `(let ((,val-to-save (if (boundp ,symbol)
  126.                  (symbol-value ,symbol)
  127.                  ,place-holder)))
  128.        (if ,old-vals
  129.        (rplacd (last ,old-vals) (ncons ,val-to-save))
  130.        (setq ,old-vals (ncons ,val-to-save))))))
  131.  
  132. (defun PORTABLE-PROGV-UNBIND (symbol old-vals place-holder)
  133.   (let ((val-to-restore '#:value-to-restore))
  134.     `(let ((,val-to-restore (pop ,old-vals)))
  135.        (if (eq ,val-to-restore ,place-holder)
  136.        (makunbound ,symbol)
  137.        (setf (symbol-value ,symbol) ,val-to-restore)))))
  138.   
  139.  
  140. (deftransform PROGV PORTABLE-PROGV-TRANSFORM
  141.           (symbols-form values-form &rest body)
  142.   (let ((symbols-lst '#:symbols-list)
  143.     (values-lst '#:values-list)
  144.     (syms '#:symbols)
  145.     (vals '#:values)
  146.     (sym '#:symbol)
  147.     (old-vals '#:old-values)
  148.     (unbound-holder ''#:unbound-holder))
  149.     `(let ((,symbols-lst ,symbols-form)
  150.        (,values-lst ,values-form)
  151.        (,old-vals nil))
  152.        (unless (and (listp ,symbols-lst) (listp ,values-lst))
  153.      (error "PROGV: Both symbols and values must be lists"))
  154.        (unwind-protect
  155.        (do ((,syms ,symbols-lst (cdr ,syms))
  156.         (,vals ,values-lst (cdr ,vals))
  157.         (,sym nil))
  158.            ((null ,syms) (progn ,@body))
  159.          (setq ,sym (car ,syms))
  160.          (if (symbolp ,sym)
  161.          ,(PORTABLE-PROGV-BIND sym old-vals unbound-holder)
  162.          (error "PROGV: Object to be bound not a symbol: ~S" ,sym))
  163.          (if ,vals
  164.          (setf (symbol-value ,sym) (first ,vals))
  165.          (makunbound ,sym)))
  166.      (dolist (,sym ,symbols-lst)
  167.        ,(PORTABLE-PROGV-UNBIND sym old-vals unbound-holder))))))
  168.  
  169.